home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / ask.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  2KB  |  56 lines
  1. ;;;; ask.jl -- Boolean prompting
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;;;###autoload
  21. (defun yes-or-no-p (question)
  22.   "Prompts the user for a yes or no answer to QUESTION, returns t for yes."
  23.   (let*
  24.       ((answer (prompt (concat question " (yes or no) "))))
  25.     (string= "yes" answer)))
  26.  
  27. (setq y-or-n-keymap (make-keylist))
  28. (bind-keys y-or-n-keymap
  29.   "n" '(throw 'ask nil)
  30.   "BS" '(throw 'ask nil)
  31.   "y" '(throw 'ask t)
  32.   "SPC" '(throw 'ask t))
  33.  
  34. ;;;###autoload
  35. (defun y-or-n-p (question)
  36.   "Prompts the user for a single keypress response, either `y' or `n' to the
  37. string QUESTION, returns t for `y'."
  38.   (let*
  39.       ((old-u-k-h unbound-key-hook)
  40.        (old-k-p keymap-path)
  41.        (buf (current-buffer))
  42.        (title-string (concat question " (y or n) ")))
  43.     (setq unbound-key-hook (cons #'(lambda ()
  44.                      (beep)
  45.                      (message title-string)) nil))
  46.     (setq keymap-path '(y-or-n-keymap)
  47.       status-line-cursor t)
  48.     (message title-string)
  49.     (unwind-protect
  50.     (catch 'ask
  51.       (recursive-edit))
  52.       (with-buffer buf
  53.     (setq keymap-path old-k-p
  54.           unbound-key-hook old-u-k-h
  55.           status-line-cursor nil)))))
  56.